Mac Format 1994 October/Macformat17.cdr/Shareware City/Developers/MungeImage Source/MungeImage.p

Text File | 1994-06-18 | 14KB | 549 lines

unit MungeImage;

interface

    function Main (dctl: DCtlPtr; pb: ParmBlkPtr; sel: integer): OSErr;

implementation

    uses
        Processes, Aliases;

    function FSReadQ (refnum: integer; count: longint; buf: Ptr): OSErr;
    begin
        FSReadQ := FSRead(refnum, count, buf);
    end; (* FSReadQ *)

    function MyFSWriteAt (refnum: integer; mode: integer; pos, len: longInt; p: ptr): OSErr;
        var
            pb: ParamBlockRec;
            oe: OSErr;
    begin
        pb.ioRefNum := refnum;
        pb.ioBuffer := p;
        pb.ioReqCount := len;
        pb.ioPosMode := mode;
        pb.ioPosOffset := pos;
        oe := PBWriteSync(@pb);
        if (oe = noErr) & (pb.ioActCount <> len) then begin
            oe := -1;
        end;
        MyFSWriteAt := oe;
    end;

    const
        max_drive_count = 15;
        kOptionKey = 58;
        disk_just_inserted = 1;
        disk_read = 2;

    type
        diskImageHeader = record
                name: Str63;
                data_size: longint;
                tag_size: longint;
                data_checksum: longint;
                tag_checksum: longint;
                unknown: longint;
            end;

    const
        dataCRCheaderOffset = 72;

    type
        driveRecord = record
                flags: signedByte;            (* the following 4 bytes must be in order and immediately in front of dqel *)
                disk_in_place: signedByte;
                drive_installed: signedByte;
                number_of_sides: signedByte;
                dqel: DrvQEl;
                image: Ptr;
                image_size: longint;
                readonly: boolean;
                alias: AliasHandle;
                writeout: boolean;
            end;

    (* disk_in_place is 0 iff (image is nil) *)

    type
        iconType = array[0..255] of signedByte;
        physIcon = record
                phys_icon: iconType;
                location_str: Str63;
            end;

    var
        AlreadyOpen: boolean;
        munge_image_psn: ProcessSerialNumber;
        phys_icon: physIcon;
        media_icon: iconType;
        drives: array[1..max_drive_count] of driveRecord;

    const
        Size_Of_Globals = sizeof(AlreadyOpen) + sizeof(munge_image_psn) + sizeof(phys_icon) * 2 + sizeof(drives) + $100;

    procedure SetRegA4 (n: univ Ptr);
    inline
        $285F;

    function CalcChecksum (data: Ptr; datasize: longint): longint;
        type
            bigArray = array[0..123456] of integer;
            bigArrayPtr = ^bigArray;
        var
            i: longint;
            word: integer;
            checksum: longint;
    begin
        if odd(datasize) then begin
            DebugStr('datasize shouldnt be odd!');
        end; (* if *)
        checksum := 0;
        for i := 0 to datasize div 2 - 1 do begin
            word := bigArrayPtr(data)^[i];
            checksum := checksum + band(word, $0000FFFF);
            checksum := brotl(checksum, 31);
        end; (* for *)
        CalcChecksum := checksum;
    end; (* CalcChecksum *)

    function DriveExists (drive_num: integer): boolean;
        var
            cur_el: DrvQElPtr;
    begin
        DriveExists := false;
        cur_el := DrvQElPtr(GetDrvQHdr^.qHead);
        while cur_el <> nil do begin
            if cur_el^.dQDrive = drive_num then begin
                DriveExists := true;
                leave;
            end; (* if *)
            cur_el := DrvQElPtr(cur_el^.qLink);
        end; (* while *)
    end; (* DriveExists *)

    function FindFreeDriveRecord (var ndx: integer): boolean;
        var
            i: integer;
    begin
        ndx := 0;
        for i := 1 to max_drive_count do begin
            if drives[i].disk_in_place = 0 then begin
                ndx := i;
                leave;
            end; (* if *)
        end; (* for *)
        FindFreeDriveRecord := (ndx <> 0);
    end; (* FindFreeDriveRecord *)

    function DriveToDriveRecord (drive_num: integer; var ndx: integer): OSErr;
        var
            i: integer;
    begin
        ndx := 0;
        for i := 1 to max_drive_count do begin
            if (drives[i].disk_in_place <> 0) and (drives[i].dqel.dQDrive = drive_num) then begin
                ndx := i;
                leave;
            end; (* if *)
        end; (* for *)
        if ndx = 0 then begin
            DriveToDriveRecord := nsDrvErr;
        end
        else begin
            DriveToDriveRecord := noErr;
        end; (* if *)
    end; (* DriveToDriveRecord *)

    function AnyDriveRecordInUse: boolean;
        var
            i: integer;
    begin
        AnyDriveRecordInUse := false;
        for i := 1 to max_drive_count do begin
            if drives[i].disk_in_place <> 0 then begin
                AnyDriveRecordInUse := true;
                leave;
            end; (* if *)
        end; (* for *)
    end; (* AnyDriveRecordInUse *)

    function Main (dctl: DCtlPtr; pb: ParmBlkPtr; sel: integer): OSErr;

        function DoOpen: OSErr;
            var
                err: OSErr;
                i: integer;
                junk: OSErr;
        begin
            err := noErr;
            if dctl^.dCtlStorage = nil then begin
                dctl^.dCtlStorage := NewHandleSysClear(Size_Of_Globals);
                err := MemError;
                if err = noErr then begin
                    HLock(dctl^.dCtlStorage);
                    SetRegA4(dctl^.dCtlStorage^);
                end;
            end;
            if (err = noErr) & not AlreadyOpen then begin
                AlreadyOpen := true;
            end;
            if err = noErr then begin
                err := GetCurrentProcess(munge_image_psn);
            end; (* if *)
            if (err = noErr) then begin
                phys_icon.location_str := GetString(128)^^;
                BlockMove(GetResource('ICN#', 200)^, @phys_icon.phys_icon, sizeof(iconType));
                BlockMove(GetResource('ICN#', 201)^, @media_icon, sizeof(media_icon));
                for i := 1 to max_drive_count do begin
                    drives[i].disk_in_place := 0;
                    drives[i].image := nil;
                end; (* for *)
            end; (* if *)
            DoOpen := err;
        end; (* DoOpen *)

        procedure CreateDriveRecord (ndx: integer);
        begin
            drives[ndx].alias := nil;
            drives[ndx].image := nil;
            drives[ndx].disk_in_place := disk_just_inserted;
            drives[ndx].writeout := false;
        end;

        procedure DestroydriveRecord (ndx: integer);
        begin
            if drives[ndx].alias <> nil then begin
                DisposeHandle(handle(drives[ndx].alias));
            end;
            if drives[ndx].image <> nil then begin
                DisposePtr(drives[ndx].image);
            end;
            drives[ndx].image := nil;
            drives[ndx].disk_in_place := 0;
            drives[ndx].writeout := false;
        end;

        function MountImage (fss: FSSpecPtr): OSErr;
            var
                err: OSErr;
                junk: OSErr;
                ndx: integer;
                header: diskImageHeader;
                refnum: integer;
                drive_num: integer;
                keys: KeyMap;
                readonly: boolean;
                oldzone: THz;
        begin
            GetKeys(keys);
            readonly := not keys[kOptionKey];
            err := noErr;
            ndx := 0;        (* important safety tip! *)
            if not FindFreeDriveRecord(ndx) then begin
                err := -666;
            end
            else begin
                CreateDriveRecord(ndx);
                if err = noErr then begin
                    err := FSpOpenDF(fss^, fsRdPerm, refnum);
                end; (* if *)
                if err = noErr then begin
                    if not readonly then begin
                        oldzone := GetZone;
                        SetZone(SystemZone);
                        err := NewAlias(nil, fss^, drives[ndx].alias);
                        SetZone(oldzone);
                    end;
                    if err = noErr then begin
                        err := FSReadQ(refnum, sizeof(header), @header);
                    end;
                    if err = noErr then begin
                        drives[ndx].image_size := header.data_size;
                        drives[ndx].image := NewPtrSys(drives[ndx].image_size);
                        err := MemError;
                    end; (* if *)
                    if err = noErr then begin
                        err := FSReadQ(refnum, drives[ndx].image_size, drives[ndx].image);
                    end; (* if *)
                    junk := FSClose(refnum);
                end; (* if *)
                if err = noErr then begin
                    drive_num := 4;
                    while DriveExists(drive_num) do begin
                        drive_num := drive_num + 1;
                    end; (* while *)
                    drives[ndx].readonly := readonly;
                    drives[ndx].flags := $80 * ord(readonly);
                    drives[ndx].drive_installed := 0;
                    drives[ndx].number_of_sides := 0;            (* ? should set to 0 for 400K disk images*)
                    drives[ndx].dqel.qType := 1;
                    drives[ndx].dqel.dQDrive := drive_num;
                    drives[ndx].dqel.dQRefNum := pb^.ioCRefNum;
                    drives[ndx].dqel.dQFSID := 0;
                    drives[ndx].dqel.dQDrvSz := drives[ndx].image_size div 512;
                    drives[ndx].dqel.dQDrvSz2 := 0;
                    AddDrive(dctl^.dCtlRefNum, drive_num, @drives[ndx].dqel);
                    junk := PostEvent(diskEvt, drive_num);
                end
                else begin
                    DestroyDriveRecord(ndx);
                end; (* if *)
            end; (* if *)
            MountImage := err;
        end; (* MountImage *)

        procedure WriteBack (ndx: integer);
            var
                err: OSErr;
                aliascount: integer;
                fss: array[1..2] of FSSPec;
                needsUpdate: boolean;
                rn: integer;
                crc: longInt;
        begin
            aliascount := 2;
            err := MatchAlias(nil, kARMNoUI + kARMSearch, drives[ndx].alias, aliascount, @fss, needsUpdate, nil, nil);
            if (err = noErr) & (aliascount <> 1) then begin
                err := -1;
            end;
            if err = noErr then begin
                err := FSpOpenDF(fss[1], fsRdWrPerm, rn);
                if err = noErr then begin
                    err := MyFSWriteAt(rn, fsFromStart, SizeOf(diskImageHeader), drives[ndx].image_size, drives[ndx].image);
                    if err = noErr then begin
                        crc := CalcChecksum(drives[ndx].image, drives[ndx].image_size);
                        err := MyFSWriteAt(rn, fsFromStart, dataCRCheaderOffset, SizeOf(crc), @crc);
                    end;
                    err := FSClose(rn);
                end;
            end;
        end;

        function UnMountImage: OSErr;
            var
                err: OSErr;
                junk: OSErr;
                ndx: integer;
        begin
            err := DriveToDriveRecord(pb^.ioVRefNum, ndx);
            if err = noErr then begin
                if DeQueue(@drives[ndx].dqel, GetDrvQHdr) <> noErr then begin
                    DebugStr('Hmm, removing a non-existant drive');
                end; (* if *)
                if not drives[ndx].readonly then begin
                    drives[ndx].writeout := true;
                end
                else begin
                    DestroyDriveRecord(ndx);
                end;
            end; (* if *)
            UnMountImage := err;
        end; (* UnMountImage *)

        function DoClose: OSErr;
            var
                err: OSErr;
        begin
            if AnyDriveRecordInUse then begin
                err := closErr;
            end
            else begin
                err := noErr;
            end; (* if *)
            DoClose := err;
        end; (* DoClose *)

        function DoPrime: OSErr;
            var
                err: OSErr;
                offset: longint;
                ndx: integer;
        begin
            err := DriveToDriveRecord(pb^.ioVRefNum, ndx);
            if err = noErr then begin
                offset := dctl^.dCtlPosition;
                if (offset < 0) or (pb^.ioReqCount < 0) or (offset + pb^.ioReqCount > drives[ndx].image_size) then begin
                    pb^.ioActCount := 0;
                    err := paramErr;
                end
                else begin
                    err := noErr;
                    pb^.ioActCount := 0;
                    if odd(pb^.ioTrap) then begin
                        (* write *)
                        if drives[ndx].readonly then begin
                            err := wPrErr;
                        end
                        else begin
                            BlockMove(pb^.ioBuffer, Ptr(ord(drives[ndx].image) + offset), pb^.ioReqCount);
                        end;
                    end
                    else begin
                        (* read *)
                        drives[ndx].disk_in_place := disk_read;
                        BlockMove(Ptr(ord(drives[ndx].image) + offset), pb^.ioBuffer, pb^.ioReqCount);
                    end; (* if *)
                    if err = noErr then begin
                        pb^.ioActCount := pb^.ioReqCount;
                        dctl^.dCtlPosition := dctl^.dCtlPosition + pb^.ioActCount;
                    end;
                end; (* if *)
            end; (* if *)
            DoPrime := err;
        end; (* DoPrime *)

        procedure DoAccRun;
            var
                i: integer;
        begin
            for i := 1 to max_drive_count do begin
                if drives[i].disk_in_place <> 0 then begin
                    if drives[i].writeout then begin
                        WriteBack(i);
                        DestroyDriveRecord(i);
                    end;
                end;
            end;
        end;

        function DoControl: OSErr;
            const
                super_drive_info = $00000404;
            var
                err: OSErr;
        begin
            case pb^.csCode of
                1:
                    err := -1; (* KillIO *)
                5:
                    err := noErr; (* Verify Disk *)
                6:
                    err := noErr; (* Format Disk *)
                7:
                    err := UnMountImage; (* Eject Disk *)
                8:
                    if pb^.ioMisc = nil then begin    (* Set Tag Buffer *)
                        err := noErr;
                    end
                    else begin
                        err := -1;
                    end; (* if *)
                9:
                    err := -1; (* Track Cache Control *)
                21:  begin    (* Return Physical Icon *)
                    pb^.ioMisc := @phys_icon;
                    err := noErr;
                end;
                22:  begin    (* Return Media Icon *)
                    pb^.ioMisc := @media_icon;
                    err := noErr;
                end;
                23:  begin (* Return Drive Info *)
                    pb^.ioMisc := Ptr(super_drive_info);
                    err := noErr;
                end;
                accRun:
                    DoAccRun;
                666:  begin
                    err := MountImage(FSSpecPtr(pb^.ioMisc));
                end;
                667:
                    err := noErr;
                18244:  begin
                    err := -1;
                end;
                otherwise
                    err := controlErr;
            end; (* case *)
            DoControl := err;
        end; (* DoControl *)

        function DoStatus: OSErr;
            const
                mfm_1440_capacity = 1440 * 2;
                mfm_1440_stuff = $D2120050;
            type
                formatDesc = record
                        capacity: longint;
                        stuff: longint;
                    end;
                formatParams = record
                        count: integer;
                        point: ^formatDesc;
                    end;
                formatParamsPtr = ^formatParams;
                statusParams = record
                        current_track: integer;
                        flags: signedByte;            (* the following 4 bytes must be in order and immediately in front of dqel *)
                        disk_in_place: signedByte;
                        drive_installed: signedByte;
                        number_of_sides: signedByte;
                        dqel: DrvQEl;
                    end;
                statusParamsPtr = ^statusParams;
            var
                err: OSErr;
                ndx: integer;
        begin
            case pb^.csCode of
                6:  begin (* Return Format List *)
                    err := DriveToDriveRecord(pb^.ioVRefNum, ndx);
                    if err = noErr then begin
                        with formatParamsPtr(@pb^.csParam)^ do begin
                            if count > 0 then begin
                                count := 1;
                                point^.capacity := drives[ndx].image_size div 512;
                                point^.stuff := 0;
                                err := noErr;
                            end
                            else begin
                                err := paramErr;
                            end; (* if *)
                        end; (* with *)
                    end; (* if *)
                end;
                8:  begin
                    err := DriveToDriveRecord(pb^.ioVRefNum, ndx);
                    if err = noErr then begin
                        with statusParamsPtr(@pb^.csParam)^ do begin
                            current_track := 0;
                            flags := drives[ndx].flags;
                            disk_in_place := drives[ndx].disk_in_place;
                            drive_installed := drives[ndx].drive_installed;
                            number_of_sides := drives[ndx].number_of_sides;
                            dqel := drives[ndx].dqel;
                            dqel.dQDrvSz := -1;
                            dqel.dQDrvSz2 := 0;
                        end; (* with *)
                        err := noErr;
                    end; (* if *)
                end;
                otherwise
                    err := controlErr;
            end; (* case *)
            DoStatus := err;
        end; (* DoStatus *)

        var
            err: OSErr;
    begin
        case sel of
            0:
                err := DoOpen;
            1:
                err := DoPrime;
            2:
                err := DoControl;
            3:
                err := DoStatus;
            4:
                err := DoClose;
            otherwise
                err := noErr;
        end; (* case *)
        Main := err;
    end; (* Main *)

end. (* MungeImage *)